home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: New Zealand Amiga Users Group / New Zealand Amiga Users Group Newsdisk v03 (1987-02)(NZAmigaUG).zip / New Zealand Amiga Users Group Newsdisk v03 (1987-02)(NZAmigaUG).adf / BASIC / ScapeGen32 < prev    next >
Text File  |  1993-12-02  |  3KB  |  81 lines
  1. REM   FRACTAL LANDSCAPES with SOLID SURFACE  by G Thornton
  2.       
  3.       CLEAR ,50000&
  4.       SCREEN 1,320,200,5,1
  5.       WINDOW 2,"Fractal landscapes MkII [<RETURN>=exit]",,0,1
  6.       RANDOMIZE TIMER: COLOR 11,2
  7.       DIM d%(128,128)
  8.       FOR i=0 TO 31:READ r,g,b:PALETTE i,r/15,g/15,b/15:NEXT
  9.       DATA 15,7,0,0,6,15,14,13,9,13,12,4,8,7,5,0,9,7,7,11,7,6,10,0,8,12,0
  10.       DATA 5,8,3,3,7,6,4,7,0,0,5,3,6,7,0,0,6,1,6,8,0,5,7,0,7,6,4
  11.       DATA 4,5,2,6,5,4,5,4,0,6,5,0,6,6,0,8,6,0,7,6,5,8,7,5,7,7,3
  12.       DATA 8,6,5,10,9,7,13,13,13,11,11,11,15,15,15
  13.       water=-200:sea=1
  14. 30    INPUT "Number of levels <1-7> ";le: IF le < 1 OR le > 7 THEN 30
  15.       INPUT "Variable smoothness (Y/N)";smoo$
  16.       IF LEFT$(UCASE$(smoo$),1)="Y" THEN hill=1 ELSE hill=0
  17.       IF hill=0 THEN INPUT "Enter smoothness (1.5 - 2.5) :",Sm 
  18. 40    mx=2^le
  19. 60    FOR n=1 TO le: IF hill=0 THEN l=15000/Sm^n
  20. 70    PRINT : PRINT  "Working on level ";n
  21. 80    ib=mx/2^n:sk=ib*2
  22. 90    GOSUB 150: ' *** Assign heights along X in array ***
  23. 100   GOSUB 220: ' *** Assign heights along Y in array ***
  24. 110   GOSUB 290: ' *** Assign heights along diag. in array ***
  25. 120   NEXT n
  26.       IF sea=0 THEN 130
  27.       FOR i=0 TO mx :FOR j=0 TO mx
  28.         IF d%(i,j)<water THEN d%(i,j)=water ELSE IF d%(i,j)>maxz THEN maxz=d%(i,j)
  29.       NEXT j,i  
  30. 130   GOTO 640:  ' *** Draw ***
  31.    ' *** Heights along x ***
  32. 150 FOR ye = 0 TO mx  STEP sk
  33.     IF hill=1 THEN l=15000/(1.3+le/20+(ye/mx*(.8-le/20)))^n
  34.     FOR xe = ib TO mx STEP sk
  35.     d%(xe,ye)=(d%(xe-ib,ye)+d%(xe+ib,ye))/2+ RND*l/2 - l/4
  36.     NEXT xe
  37.     NEXT ye: RETURN
  38.    ' *** Heights along Y ***
  39. 220 FOR ye = ib TO mx STEP sk
  40.     IF hill=1 THEN l=15000/(1.3+le/20+(ye/mx*(.8-le/20)))^n
  41.     FOR xe = 0 TO mx STEP sk
  42.     d%(xe,ye)=(d%(xe,ye-ib)+d%(xe,ye+ib))/2+ RND * l/2 - l/4
  43.     NEXT xe
  44.     NEXT ye: RETURN
  45.    ' *** Heights along diag. ***
  46. 290   sq2=SQR(2)
  47.     FOR ye = ib TO mx  STEP sk
  48.     IF hill=1 THEN l=15000/(1.3+le/20+(ye/mx*(.8-le/20)))^n
  49.     FOR xe = ib TO mx  STEP sk
  50.     d%(xe,ye)=(d%(xe-ib,ye+ib)+d%(xe+ib,ye-ib))/2+RND(1)*l/sq2-l/sq2/2
  51.     NEXT xe
  52.     NEXT ye: RETURN
  53. 630   ' **** Display here ****
  54. 640   GOSUB 1100: ' *** Set up plotting device or screen ***
  55.     xa=35/mx/mx: ys = 120/mx: yc=50:zs=yc/maxz*.85: ' *** scaling factors ***
  56.     FOR ay = 0 TO mx-1 :ays=ay*ys+yc:xs=(270+35*ay/mx)/mx
  57.     FOR ax = 0 TO mx-1 :axs=ax*xs:ax1=axs+xs
  58.     z1=d%(ax,ay):z2=d%(ax,ay+1):z3=d%(ax+1,ay)
  59.     GOSUB Tricolour :ay2=ays+ys-z2*zs:ay3=ays-z3*zs
  60.     AREA(axs,ays-z1*zs):AREA(axs+xa*ax,ay2):AREA(ax1,ay3):AREAFILL
  61.     z1=d%(ax+1,ay+1):GOSUB Tricolour
  62.     AREA(ax1+xa*(ax+1),ays+ys-z1*zs):AREA(axs,ay2):AREA(ax1,ay3):AREAFILL
  63.     NEXT ax,ay
  64.     GOTO 1130: ' *** done plotting, goto end loop ***
  65.  
  66. Tricolour: height=(z1+z2+z3)/3 - water:IF height<10 THEN COLOR 1:RETURN
  67.  hi=INT(height/maxz*10+RND*.4):IF hi>9 THEN hi=9
  68.   slp=INT(RND*2.99)
  69.   COLOR 2+slp+hi*3
  70.   RETURN
  71.   
  72. 1100  ' * * * setup plotting device or screen * * *
  73. 1110  CLS: LINE (0,0)-(310,190),0,bf: RETURN
  74. 1120  ' *** End loop ***
  75. 1130  '
  76. 1140  INPUT "",e$
  77.       SCREEN CLOSE 1
  78.       END
  79.  
  80.  
  81.